home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / Pascal / Applications / MakeFat 1.0 / MakeFat.p < prev    next >
Encoding:
Text File  |  1995-12-01  |  6.2 KB  |  243 lines  |  [TEXT/CWIE]
  1. program MakeFat;
  2.  
  3.     uses
  4.         Resources,
  5.         MyInitialization, MyRequiredEventSupport, MySystemGlobals, MyUtils, MyFileSystemUtils, 
  6.         MyStrings, MyEmergencyNotifier;
  7.     
  8.     var
  9.         quitNow:Boolean;
  10.         first:Boolean;
  11.         fs1,fs2:FSSpec;
  12.     
  13.     type
  14.         KindType = (K_Unknown, K_68k, K_PPC);
  15.     
  16.     procedure Debug(s:Str255);
  17.     begin
  18.         EmergencyNotify(s);
  19.     end;
  20.     
  21.     function ProcessPair:OSErr;
  22.         procedure Check(t:Boolean; msg:Str255);
  23.         begin
  24.             if not t then begin
  25.                 Debug(msg);
  26.                 Exit(ProcessPair);
  27.             end;
  28.         end;
  29.         
  30.         function FSpOpenResFileNoResLoad(var fs:FSSpec; perm:integer):integer;
  31.         begin
  32.             SetResLoad(false);
  33.             FSpOpenResFileNoResLoad := FSpOpenResFile(fs, perm);
  34.             SetResLoad(true);
  35.         end;
  36.         
  37.         function Get1ResourceNoResLoad(typ:OSType; id:integer):Handle;
  38.         begin
  39.             SetResLoad(false);
  40.             Get1ResourceNoResLoad:=Get1Resource(typ, id);
  41.             SetResLoad(true);
  42.         end;
  43.         
  44.         function Get1IndResourceNoResLoad(typ:OSType; index:integer):Handle;
  45.         begin
  46.             SetResLoad(false);
  47.             Get1IndResourceNoResLoad:=Get1IndResource(typ, index);
  48.             SetResLoad(true);
  49.         end;
  50.         
  51.         procedure Compare(rn1, rn2:integer; reversed:Boolean);
  52.             var
  53.                 typ:OSType;
  54.                 typ_index:integer;
  55.                 index:integer;
  56.                 h1, h2:Handle;
  57.                 the_type:OSType;
  58.                 the_name:Str255;
  59.                 id1, id2:integer;
  60.                 size1, size2:longInt;
  61.                 skip:Boolean;
  62.         begin
  63.             UseResFile(rn1);
  64.             for typ_index := 1 to Count1Types do begin
  65.                 UseResFile(rn1);
  66.                 Get1IndType(typ,typ_index);
  67.                 for index := 1 to Count1Resources(typ) do begin
  68.                     UseResFile(rn1);
  69.                     h1 := Get1IndResourceNoResLoad(typ, index);
  70.                     GetResInfo(h1,id1,the_type,the_name);
  71.                     size1 := GetResourceSizeOnDisk(h1);
  72.                     ReleaseResource(h1);
  73.                     
  74.                     UseResFile(rn2);
  75.                     h2 := Get1ResourceNoResLoad(typ, id1);
  76.                     if h2 = nil then begin
  77.                         if reversed then begin
  78.                             skip := (typ = 'cfrg') & (id1 = 0);
  79.                         end else begin
  80.                             skip := (typ='CODE') or (typ='DATA');
  81.                         end;
  82.                         if not skip then begin
  83.                             Debug(concat(OSTypeToString(typ),'=',NumToStr(id1),' is missing'));
  84.                         end;
  85.                     end else begin
  86.                         GetResInfo(h2,id2,the_type,the_name);
  87.                         size2 := GetResourceSizeOnDisk(h2);
  88.                         ReleaseResource(h2);
  89.                         
  90.                         if (size1 <> size2) then begin
  91.                             Debug(concat(OSTypeToString(typ),'=',NumToStr(id1),' different sizes'));
  92.                         end;
  93.                     end;
  94.                 end;
  95.             end;
  96.         end;
  97.         
  98.         var
  99.             name:Str63;
  100.             tfs, dest:FSSpec;
  101.             pb: CInfoPBRec;
  102.             rn1, rn2, rnd:integer;
  103.             h:Handle;
  104.             dlen:longInt;
  105.             err:OSErr;
  106.     begin
  107.         ProcessPair := -1;
  108.         name := '';
  109.         Check(not IsExtension(fs1.name,'FAT') & not IsExtension(fs2.name,'FAT'), 'No no, drop the 68k and PPC applications on to this, not the FAT application!');
  110.         if IsExtension(fs1.name,'68k') then begin
  111.             name := copy(fs1.name,1,length(fs1.name)-3);
  112.         end else if IsExtension(fs2.name,'PPC') then begin
  113.             name := copy(fs2.name,1,length(fs2.name)-3);
  114.         end else if IsExtension(fs2.name,'68k') then begin
  115.             tfs := fs1; fs1 := fs2; fs2 := tfs;
  116.             name := copy(fs1.name,1,length(fs1.name)-3);
  117.         end else if IsExtension(fs2.name,'PPC') then begin
  118.             tfs := fs1; fs1 := fs2; fs2 := tfs;
  119.             name := copy(fs2.name,1,length(fs2.name)-3);
  120.         end;
  121.         Check(name <> '', 'Couldnt find 68k or PPC in names');
  122.         if (IUEqualString(name, fs1.name) = 0) or (IUEqualString(name, fs2.name) = 0) then begin
  123.             name := concat(name,'FAT');
  124.         end;
  125.         if (IUEqualString(name, fs1.name) = 0) or (IUEqualString(name, fs2.name) = 0) then begin
  126.             LimitStringLength(name,30,'…');
  127.             name := concat(name,'#');
  128.         end;
  129.         
  130.         err := FSpGetCatInfo (fs1, 0, pb);
  131.         Check(err = noErr, 'Cant get info on 68k file');
  132.         Check(pb.ioFlLgLen = 0, '68k file has data fork');
  133.         
  134.         err := FSpGetCatInfo (fs2, 0, pb);
  135.         Check(err = noErr, 'Cant get info on PPC file');
  136.         Check(pb.ioFlLgLen <> 0, 'PPC file has no data fork');
  137.         dlen := pb.ioFlLgLen;
  138.         
  139.         rn1:=FSpOpenResFileNoResLoad(fs1,fsRdPerm);
  140.         Check(rn1 <> -1, 'Cant open 68k res file');
  141.         h:=Get1ResourceNoResLoad('CODE',0);
  142.         Check(h <> nil, '68k doesnt have a CODE=0');
  143.         h:=Get1IndResourceNoResLoad('cfrg',1);
  144.         Check(h = nil, '68k has a cfrg resource');
  145.  
  146.  
  147.         rn2:=FSpOpenResFileNoResLoad(fs2,fsRdPerm);
  148.         Check(rn2 <> -1, 'Cant open PPC res file');
  149.         h:=Get1IndResourceNoResLoad('CODE',1);
  150.         Check(h = nil, 'PPC has a CODE resource');
  151.         h:=Get1ResourceNoResLoad('cfrg',0);
  152.         Check(h <> nil, 'PPC doesnt have a cfrg=0');
  153.         
  154.         Compare(rn1,rn2,false);
  155.         Compare(rn2,rn1,true);
  156.         
  157.         CloseResFile(rn1);
  158.         CloseResFile(rn2);
  159.         
  160.         err:=FSMakeFSSpec(fs1.vRefNum,fs1.parID,name,dest);
  161.         err:=FSpDelete(dest);
  162.         err := DuplicateFile(fs1, dest);
  163.         Check(err = noErr, 'Duplicate failed');
  164.         
  165.         err := FSpOpenDF(fs2, fsRdPerm, rn2);
  166.         Check(err = noErr, 'Cant open PPC data fork');
  167.         err := FSpOpenDF(dest, fsWrPerm, rnd);
  168.         Check(err = noErr, 'Cant open FAT data fork');
  169.         err := CopyData(rn2, rnd, dlen);
  170.         Check(err = noErr, 'Copy data fork failed');
  171.         err := FSClose(rn2);
  172.         Check(err = noErr, 'Close source data fork failed');
  173.         err := FSClose(rnd);
  174.         Check(err = noErr, 'Close dest data fork failed');
  175.  
  176.         rn2:=FSpOpenResFileNoResLoad(fs2,fsRdPerm);
  177.         Check(rn2 <> -1, 'Cant open PPC res file (2)');
  178.         h:=Get1Resource('cfrg',0);
  179.         Check(h <> nil, 'PPC doesnt have a cfrg=0');
  180.         DetachResource(h);
  181.         CloseResFile(rn2);
  182.         
  183.         rnd:=FSpOpenResFileNoResLoad(dest,fsRdWrPerm);
  184.         Check(rnd <> -1, 'Cant open FAT res file (2)');
  185.         AddResource(h,'cfrg',0,'');
  186.         CloseResFile(rnd);
  187.         ProcessPair := noErr;
  188.     end;
  189.     
  190.     function DoQuit: OSErr;
  191.     begin
  192.         quitNow := true;
  193.         DoQuit := noErr;
  194.     end;
  195.     
  196.     function DoOApp: OSErr;
  197.     begin
  198.         quitNow := true;
  199.         EmergencyNotify('No, no, drop the 68k and PPC applications on to me, and I’ll make the FAT application');
  200.         DoOApp := noErr;
  201.     end;
  202.     
  203.     function DoODoc (var fs: FSSpec): OSErr;
  204.     begin
  205.         if first then begin
  206.             fs1 := fs;
  207.             DoODoc := noErr;
  208.         end else begin
  209.             fs2 := fs;
  210.             DoODoc := ProcessPair;
  211.             quitNow := true;
  212.         end;
  213.         first := not first;
  214.     end;
  215.     
  216.     procedure WNE;
  217.         var
  218.             dummy:Boolean;
  219.             er:EventRecord;
  220.             err:OSErr;
  221.     begin
  222.         dummy:=WaitNextEvent(everyEvent,er,0,nil);
  223.         if er.what = keyDown then begin
  224.             quitNow := true;
  225.         end;
  226.         if er.what = kHighLevelEvent then begin
  227.             err := AEProcessAppleEvent(er);
  228.         end;
  229.     end;
  230.  
  231. begin
  232.     Initialization;
  233.     InitSystemGlobals;;
  234.     if system7 then begin
  235.         InitAppleEvents (DoOApp, DoODoc, nil, DoQuit);
  236.         first := true;
  237.         quitNow:=false;
  238.         while not quitNow do begin
  239.             WNE;
  240.         end;
  241.     end;
  242. end.
  243.